home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / uim / im.scm < prev    next >
Encoding:
Text File  |  2010-11-07  |  16.2 KB  |  548 lines
  1. ;;; im.scm: Core IM management functions for uim
  2. ;;;
  3. ;;; Copyright (c) 2003-2009 uim Project http://code.google.com/p/uim/
  4. ;;;
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Redistribution and use in source and binary forms, with or without
  8. ;;; modification, are permitted provided that the following conditions
  9. ;;; are met:
  10. ;;; 1. Redistributions of source code must retain the above copyright
  11. ;;;    notice, this list of conditions and the following disclaimer.
  12. ;;; 2. Redistributions in binary form must reproduce the above copyright
  13. ;;;    notice, this list of conditions and the following disclaimer in the
  14. ;;;    documentation and/or other materials provided with the distribution.
  15. ;;; 3. Neither the name of authors nor the names of its contributors
  16. ;;;    may be used to endorse or promote products derived from this software
  17. ;;;    without specific prior written permission.
  18. ;;;
  19. ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND
  20. ;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  21. ;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  22. ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE
  23. ;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  24. ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  25. ;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  26. ;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  27. ;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  28. ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  29. ;;; SUCH DAMAGE.
  30. ;;;;
  31.  
  32. (require-extension (srfi 2 6 23 34))
  33.  
  34. ; Comment should be written in English, UTF-8.
  35. ;
  36. (require "util.scm")
  37. (require "i18n.scm")
  38. (require "load-action.scm")
  39.  
  40. ;; config
  41. (define default-im-name #f)
  42.  
  43. ;; preedit attributes: should be moved to another file
  44. (define preedit-none      0)
  45. (define preedit-underline 1)
  46. (define preedit-reverse   2)
  47. (define preedit-cursor    4)
  48. (define preedit-separator 8)
  49. (define preedit-attr?
  50.   (lambda (attr)
  51.     (memv attr (list preedit-none
  52.              preedit-underline
  53.              preedit-reverse
  54.              preedit-cursor
  55.              preedit-separator))))
  56.  
  57. (define text-area-id-alist
  58.   '((primary   . 1)
  59.     (selection . 2)
  60.     (clipboard . 4)))
  61.  
  62. (define text-origin-alist
  63.   '((cursor    . 1)
  64.     (beginning . 2)
  65.     (end       . 3)))
  66.  
  67. (define text-extent-alist
  68.   '((full       . -2)
  69.     (paragraph  . -3)
  70.     (sentence   . -5)
  71.     (word       . -9)
  72.     (char-frags . -17)
  73.     (disp-rect  . -33)
  74.     (disp-line  . -65)
  75.     (line       . -129)))
  76.  
  77. ;;
  78. ;; im-management
  79. ;;
  80. (define im-list ())
  81.  
  82. (define installed-im-list ())
  83. (define enabled-im-list ())
  84.  
  85. (define-record 'im
  86.   (list
  87.    (list 'name                        #f)  ;; must be first member
  88.    (list 'lang                        "")
  89.    (list 'encoding                    "")
  90.    (list 'name-label                  "")  ;; under discussion
  91.    (list 'short-desc                  "")
  92.    (list 'init-arg                    #f)
  93.    (list 'init-handler                list)
  94.    (list 'release-handler             list)
  95.    (list 'mode-handler                list)
  96.    (list 'key-press-handler           list)
  97.    (list 'key-release-handler         list)
  98.    (list 'reset-handler               list)
  99.    (list 'get-candidate-handler       list)
  100.    (list 'set-candidate-index-handler list)
  101.    (list 'prop-activate-handler       list)
  102.    (list 'input-string-handler        list)
  103.    (list 'focus-in-handler            list)
  104.    (list 'focus-out-handler           list)
  105.    (list 'place-handler               list)
  106.    (list 'displace-handler            list)
  107.    (list 'module-name                 "")))
  108.  
  109. (define im-custom-set-handler
  110.   (lambda (im)
  111.     (if (symbol-bound? 'custom-prop-update-custom-handler)
  112.     custom-prop-update-custom-handler
  113.     list)))
  114.  
  115. (define normalize-im-list
  116.   (lambda ()
  117.     (let ((ordinary-im-list (alist-delete 'direct im-list eq?))
  118.       (direct-im (retrieve-im 'direct)))
  119.       (if direct-im
  120.       (set! im-list (cons direct-im
  121.                   ordinary-im-list))))))
  122.  
  123. ;; TODO: rewrite test
  124. ;; accepts overwrite register
  125. ;; returns whether initial register or not
  126. (define register-im
  127.   (lambda (name lang encoding name-label short-desc init-arg init release
  128.         mode key-press key-release reset
  129.         get-candidate set-candidate-index prop input-string
  130.         focus-in focus-out place displace)
  131.     ;; Rejects symbols that cannot be valid external representation such
  132.     ;; as "scim-Probhat(phonetic)", "3foo", "#foo", ...
  133.     (if (guard (err (else #t))
  134.       (not (eq? name
  135.             (read (open-input-string (symbol->string name))))))
  136.     (begin
  137.       (if (symbol-bound? 'uim-notify-fatal)
  138.           (uim-notify-fatal (N_ "invalid IM name")))
  139.       (error "invalid IM name")))
  140.     (and (or (null? enabled-im-list)  ;; bootstrap
  141.          (memq name enabled-im-list)
  142.          (eq? name 'direct))  ;; direct IM must always be enabled
  143.      (let ((im (im-new name lang encoding name-label short-desc
  144.                init-arg init release
  145.                mode key-press key-release reset
  146.                get-candidate set-candidate-index prop
  147.                input-string focus-in focus-out place displace
  148.                currently-loading-module-name))
  149.                (initial-registration? (not (assq name im-list))))
  150.        (set! im-list (alist-replace im im-list))
  151.        (normalize-im-list)
  152.            initial-registration?))))
  153.  
  154. ;; strictly find out im by name
  155. (define retrieve-im
  156.   (lambda (name)
  157.     (and name
  158.      (let ((im (assq name im-list)))
  159.        im))))
  160.  
  161. (define default-im-for-debug
  162.   (lambda ()
  163.     (and (provided? "debug")
  164.      (let* ((str (getenv "UIM_IM_ENGINE"))
  165.         (sym (and str
  166.               (string->symbol str))))
  167.        (retrieve-im sym)))))
  168.  
  169. (define find-im-for-locale
  170.   (lambda (localestr)
  171.     (let* ((lang (locale-zh-awared-lang (locale-new localestr)))
  172.        (ims-for-lang (filter (lambda (im)
  173.                    (langgroup-covers? (im-lang im)
  174.                               lang))
  175.                  im-list))
  176.        (preference-ordered (and (not (null? ims-for-lang))
  177.                     (reverse ims-for-lang))))
  178.       (and (not (null? preference-ordered))
  179.        (car preference-ordered)))))
  180.  
  181. (define find-default-im
  182.   (lambda (localestr)
  183.     (or (default-im-for-debug)
  184.     (retrieve-im default-im-name)
  185.     (find-im-for-locale localestr))))
  186.  
  187. ;; find most suitable im by im-name and lang
  188. (define find-im
  189.   (lambda (name localestr)
  190.     (or (retrieve-im name)
  191.     (find-default-im localestr))))
  192.  
  193. (define uim-filter-convertible-ims
  194.   (lambda (uc)
  195.     (filter (lambda (im)
  196.               (im-convertible? uc (im-encoding im)))
  197.             im-list)))
  198.  
  199. (define uim-n-convertible-ims
  200.   (lambda (uc)
  201.     (length (uim-filter-convertible-ims uc))))
  202.  
  203. (define uim-nth-convertible-im
  204.   (lambda (uc n)
  205.     (guard (err
  206.             (else #f))
  207.       (list-ref (uim-filter-convertible-ims uc) n))))
  208.  
  209. ;; called from uim_get_default_im_name()
  210. (define uim-get-default-im-name
  211.   (lambda (localestr)
  212.     (let ((name (im-name (find-default-im localestr))))
  213.       (symbol->string name))))
  214.  
  215. ;; called from uim_get_im_name_for_locale()
  216. (define uim-get-im-name-for-locale
  217.   (lambda (localestr)
  218.     (let ((name (im-name (find-im-for-locale localestr))))
  219.       (symbol->string name))))
  220.  
  221. ;;
  222. ;; im-switching
  223. ;;
  224.  
  225. ;; for C
  226. (define uim-switch-im
  227.   (lambda (uc name)
  228.     (reset-handler uc)
  229.     ;; Don't use remove-context. old and new context must (eq? old new)
  230.     (invoke-handler im-release-handler uc)
  231.     (let ((cur-context (im-retrieve-context uc))
  232.           (new-context (create-context uc #f name)))
  233.       (remove-context new-context)
  234.       (set-cdr! cur-context (cdr new-context))
  235.       (setup-context cur-context))))
  236.  
  237. ;; for Scheme
  238. (define im-switch-im
  239.   (lambda (c name)
  240.     (let ((uc (if (pair? c)
  241.                   (context-uc c)
  242.                   c)))
  243.       (uim-switch-im uc name)
  244.       (im-raise-configuration-change uc))))
  245.  
  246. (define next-im
  247.   (lambda (name)
  248.     (let* ((im-names enabled-im-list)
  249.        (im-rest (memq name im-names)))
  250.       (or (and im-rest
  251.            (pair? (cdr im-rest))
  252.            (cadr im-rest))
  253.       (car im-names)))))
  254.  
  255. (define next-im-for-switch-im
  256.   (lambda (name)
  257.     (let ((im (next-im name)))
  258.       (or
  259.        (and
  260.     switch-im-skip-direct-im?
  261.     (eq? im 'direct)
  262.     (next-im im))
  263.        im))))
  264.  
  265. ;; 'switch-im' is not a API but an IM-switching method. Don't confuse with
  266. ;; im-switch-im
  267. (define switch-im
  268.   (lambda (uc name)
  269.     (im-switch-im uc (next-im-for-switch-im name))))
  270.  
  271. ;; FIXME: Input states are kept only if the state is appeared in the
  272. ;; toolbar.
  273. (define toggle-im
  274.   (lambda (uc c)
  275.     (let* ((cur-state (toggle-state-new (context-primary-im? c)
  276.                     (im-name (context-im c))
  277.                     (context-current-widget-states c)))
  278.        (saved-state (context-toggle-state c)))
  279.       (im-switch-im uc (if saved-state
  280.                (toggle-state-im-name saved-state)
  281.                toggle-im-alt-im))
  282.       ;; retrieve new context replaced by im-switch-im
  283.       (let ((c (im-retrieve-context uc)))
  284.     (if saved-state
  285.         (let ((orig-wstates (toggle-state-widget-states saved-state)))
  286.           (context-update-widget-states! c orig-wstates)))
  287.     (context-set-toggle-state! c cur-state)))))
  288.  
  289. (define reset-toggled-im
  290.   (lambda (uc c)
  291.     (let ((saved-state (context-toggle-state c)))
  292.       (im-switch-im uc (if saved-state
  293.                (toggle-state-im-name saved-state)
  294.                default-im-name)))))
  295.  
  296. (define reset-toggle-context!
  297.   (lambda (uc ctx)
  298.     (if (not (context-primary-im? ctx))
  299.     (reset-toggled-im uc ctx))
  300.     ;; ctx may be expired by the toggle-im
  301.     (context-set-toggle-state! (im-retrieve-context uc) #f)))
  302.  
  303. ;;
  304. ;; context-management
  305. ;;
  306. (define context-list ())
  307.  
  308. (define context-rec-spec
  309.   '((uc           #f)  ;; Scheme-wrapped uim_context. must be first member
  310.     (im           #f)
  311.     (widgets      ())  ;; may be renamed
  312.     (toggle-state #f)
  313.     (key-passthrough #f)))
  314. (define-record 'context context-rec-spec)
  315. ;; backward compatibility: should be replaced with context-uc and
  316. ;; context-set-uc!
  317. (define context-id context-uc)
  318. (define context-set-id! context-set-uc!)
  319.  
  320. (define toggle-state-rec-spec
  321.   '((primary?      #f)
  322.     (im-name       #f)
  323.     (widget-states ())))
  324. (define-record 'toggle-state toggle-state-rec-spec)
  325.  
  326. (define context-primary-im?
  327.   (lambda (c)
  328.     (let ((toggle-state (context-toggle-state c)))
  329.       (or (not toggle-state)
  330.       (not (toggle-state-primary? toggle-state))))))
  331.  
  332. (define context-primary-im-name
  333.   (lambda (c)
  334.     (if (context-primary-im? c)
  335.     (im-name (context-im c))
  336.     (toggle-state-im-name (context-toggle-state c)))))
  337.  
  338. ;; FIXME: implement
  339. (define context-focused?
  340.   (lambda (c)
  341.     #t))
  342.  
  343. (define remove-context
  344.   (lambda (c)
  345.     (set! context-list
  346.       (delete c context-list eq?))))
  347.  
  348. (define register-context
  349.   (lambda (c)
  350.     (set! context-list
  351.       (cons c context-list))))
  352.  
  353. (define create-context
  354.   (lambda (uc lang name)
  355.     (let* ((im (find-im name lang))
  356.        (arg (and im (im-init-arg im))))
  357.       (im-set-encoding uc (im-encoding im))
  358.       (let* ((handler (im-init-handler im))
  359.          (c (handler uc im arg)))
  360.     (register-context c)
  361.         ;; im-* procedures that require uc->sc must not called here since it
  362.         ;; is not filled yet. Place such procedures to setup-context.
  363.         c))))
  364.  
  365. ;; post create-context setup
  366. (define setup-context
  367.   (lambda (c)
  368.     (let ((widget-ids (context-widgets c)))
  369.       (update-style uim-color-spec (symbol-value uim-color))
  370.       (context-init-widgets! c widget-ids))))
  371.  
  372. (define release-context
  373.   (lambda (uc)
  374.     (invoke-handler im-release-handler uc)
  375.     (remove-context (im-retrieve-context uc))
  376.     #f))
  377.  
  378. (define uim-context-im
  379.   (lambda (uc)
  380.     (let ((c (im-retrieve-context uc)))
  381.       (and c
  382.            (context-im c)))))
  383.  
  384. (define uim-context-encoding
  385.   (lambda (uc)
  386.     (and-let* ((im (uim-context-im uc)))
  387.       (im-encoding im))))
  388.  
  389. (define context-update-preedit
  390.   (lambda (context segments)
  391.     (im-clear-preedit context)
  392.     (for-each (lambda (segment)
  393.         (if segment
  394.             (let ((attr (car segment))
  395.               (str (cdr segment)))
  396.               (im-pushback-preedit context attr str))))
  397.           segments)
  398.     (im-update-preedit context)))
  399.  
  400. ;; Backward compatibility. The term 'commit' is incorrect. No commit
  401. ;; operation is performed by this. This actually instructs 'pass-through' the
  402. ;; input key. The key filtering interface will be replaced with 'filtered'
  403. ;; boolean value returned by key-*-handler of each IM in some future. Current
  404. ;; semantics is not an ordinary design for IM and felt unnatural.
  405. ;;   -- YamaKen 2007-01-10
  406. (define im-commit-raw
  407.   (lambda (c)
  408.     (context-set-key-passthrough! (if (pair? c)
  409.                                       c
  410.                                       (im-retrieve-context c))
  411.                                   #t)))
  412.  
  413. ;; Deprecated
  414. (define im-get-raw-key-str
  415.   (lambda (key state)
  416.     (and (integer? key)
  417.      (<= key 255)
  418.      (integer? state)
  419.      (cond
  420.       ((= state 0)
  421.        (charcode->string key))
  422.       ((= state (assq-cdr 'Shift_key key-state-alist))
  423.        (charcode->string (ichar-upcase key)))
  424.       (else
  425.        #f)))))
  426.  
  427. ;;
  428. ;; dispatchers
  429. ;;
  430. (define invoke-handler
  431.   (lambda args
  432.     (let* ((handler-reader (car args))
  433.        (uc (cadr args))
  434.        (c (im-retrieve-context uc))
  435.        (handler-args (cons c (cddr args)))
  436.        (im (and c (context-im c)))
  437.        (handler (and im (handler-reader im)))
  438.        (result (and handler
  439.             (apply handler handler-args))))
  440.       (context-update-widgets c)
  441.       result)))
  442.  
  443. ;; Returns #t if input is filtered.
  444. ;; Don't discard unnecessary key events. They are necessary for
  445. ;; proper GUI widget handling. More correction over entire uim
  446. ;; codes is needed.
  447. (define key-press-handler
  448.   (lambda (uc key state)
  449.     (let* ((c (im-retrieve-context uc))
  450.        (im (and c (context-im c))))
  451.       (context-set-key-passthrough! c #f)
  452.       (cond
  453.        ((and enable-im-toggle?
  454.          (toggle-im-key? key state))
  455.     (toggle-im uc c))
  456.        ((and enable-im-switch?
  457.          (switch-im-key? key state))
  458.     (switch-im uc (im-name im)))
  459.        ((modifier-key? key state)
  460.     ;; don't discard modifier press/release edge for apps
  461.     (im-commit-raw c))
  462.        (else
  463.     (invoke-handler im-key-press-handler uc key state)))
  464.       (not (context-key-passthrough c)))))
  465.  
  466. ;; Returns #t if input is filtered.
  467. (define key-release-handler
  468.   (lambda (uc key state)
  469.     (let ((c (im-retrieve-context uc)))
  470.       (context-set-key-passthrough! c #f)
  471.       (cond
  472.        ((modifier-key? key state)
  473.     ;; don't discard modifier press/release edge for apps
  474.     (im-commit-raw c))
  475.        (else
  476.     (invoke-handler im-key-release-handler uc key state)))
  477.       (not (context-key-passthrough c)))))
  478.  
  479. (define reset-handler
  480.   (lambda (uc)
  481.     (invoke-handler im-reset-handler uc)))
  482.  
  483. (define focus-in-handler
  484.   (lambda (uc)
  485.     (invoke-handler im-focus-in-handler uc)))
  486.  
  487. (define focus-out-handler
  488.   (lambda (uc)
  489.     (invoke-handler im-focus-out-handler uc)))
  490.  
  491. (define place-handler
  492.   (lambda (uc)
  493.     (invoke-handler im-place-handler uc)))
  494.  
  495. (define displace-handler
  496.   (lambda (uc)
  497.     (invoke-handler im-displace-handler uc)))
  498.  
  499. (define mode-handler
  500.   (lambda (uc mode)
  501.     (invoke-handler im-mode-handler uc mode)))
  502.  
  503. (define prop-activate-handler
  504.   (lambda (uc message)
  505.     (invoke-handler im-prop-activate-handler uc message)))
  506.  
  507. (define input-string-handler
  508.   (lambda (uc str)
  509.     (invoke-handler im-input-string-handler uc str)))
  510.  
  511. (define custom-set-handler
  512.   (lambda (uc custom-sym custom-val)
  513.     (invoke-handler im-custom-set-handler uc custom-sym custom-val)))
  514.  
  515. (define get-candidate
  516.   (lambda (uc idx accel-enum-hint)
  517.     (invoke-handler im-get-candidate-handler uc idx accel-enum-hint)))
  518.  
  519. (define set-candidate-index
  520.   (lambda (uc idx)
  521.     (invoke-handler im-set-candidate-index-handler uc idx)))
  522.  
  523. (define im-acquire-text
  524.   (lambda (c id origin former-len latter-len)
  525.     (let ((text-id (cdr (assq id text-area-id-alist)))
  526.           (text-origin (cdr (assq origin text-origin-alist)))
  527.       (text-extent-former (if (symbol? former-len)
  528.                   (cdr (assq former-len text-extent-alist))
  529.                   former-len))
  530.       (text-extent-latter (if (symbol? latter-len)
  531.                   (cdr (assq latter-len text-extent-alist))
  532.                   latter-len)))
  533.       (im-acquire-text-internal
  534.        c text-id text-origin text-extent-former text-extent-latter))))
  535.  
  536. (define im-delete-text
  537.   (lambda (c id origin former-len latter-len)
  538.     (let ((text-id (cdr (assq id text-area-id-alist)))
  539.           (text-origin (cdr (assq origin text-origin-alist)))
  540.       (text-extent-former (if (symbol? former-len)
  541.                   (cdr (assq former-len text-extent-alist))
  542.                   former-len))
  543.       (text-extent-latter (if (symbol? latter-len)
  544.                   (cdr (assq latter-len text-extent-alist))
  545.                   latter-len)))
  546.       (im-delete-text-internal
  547.        c text-id text-origin text-extent-former text-extent-latter))))
  548.